home *** CD-ROM | disk | FTP | other *** search
/ Aminet 52 / Aminet 52 (2002)(GTI - Schatztruhe)[!][Dec 2002].iso / Aminet / dev / gg / ncurses-5.3.lha / ncurses-5.3 / Ada95 / samples / ncurses2-attr_test.adb < prev    next >
Text File  |  2002-10-24  |  14KB  |  368 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                       GNAT ncurses Binding Samples                       --
  4. --                                                                          --
  5. --                                 ncurses                                  --
  6. --                                                                          --
  7. --                                 B O D Y                                  --
  8. --                                                                          --
  9. ------------------------------------------------------------------------------
  10. -- Copyright (c) 2000 Free Software Foundation, Inc.                        --
  11. --                                                                          --
  12. -- Permission is hereby granted, free of charge, to any person obtaining a  --
  13. -- copy of this software and associated documentation files (the            --
  14. -- "Software"), to deal in the Software without restriction, including      --
  15. -- without limitation the rights to use, copy, modify, merge, publish,      --
  16. -- distribute, distribute with modifications, sublicense, and/or sell       --
  17. -- copies of the Software, and to permit persons to whom the Software is    --
  18. -- furnished to do so, subject to the following conditions:                 --
  19. --                                                                          --
  20. -- The above copyright notice and this permission notice shall be included  --
  21. -- in all copies or substantial portions of the Software.                   --
  22. --                                                                          --
  23. -- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS  --
  24. -- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF               --
  25. -- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.   --
  26. -- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,   --
  27. -- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR    --
  28. -- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR    --
  29. -- THE USE OR OTHER DEALINGS IN THE SOFTWARE.                               --
  30. --                                                                          --
  31. -- Except as contained in this notice, the name(s) of the above copyright   --
  32. -- holders shall not be used in advertising or otherwise to promote the     --
  33. -- sale, use or other dealings in this Software without prior written       --
  34. -- authorization.                                                           --
  35. ------------------------------------------------------------------------------
  36. --  Author: Eugene V. Melaragno <aldomel@ix.netcom.com> 2000
  37. --  Version Control
  38. --  $Revision: 1.2 $
  39. --  Binding Version 01.00
  40. ------------------------------------------------------------------------------
  41. with ncurses2.util; use ncurses2.util;
  42. with Terminal_Interface.Curses; use Terminal_Interface.Curses;
  43. with Terminal_Interface.Curses.Terminfo;
  44. use Terminal_Interface.Curses.Terminfo;
  45. with Ada.Characters.Handling;
  46. with Ada.Strings.Fixed;
  47.  
  48. procedure ncurses2.attr_test is
  49.  
  50.    function  subset (super, sub : Character_Attribute_Set) return Boolean;
  51.    function  intersect (b, a : Character_Attribute_Set) return Boolean;
  52.    function  has_A_COLOR (attr : Attributed_Character) return Boolean;
  53.    function  show_attr (row  : Line_Position;
  54.                         skip : Natural;
  55.                         attr : Character_Attribute_Set;
  56.                         name : String;
  57.                         once : Boolean) return Line_Position;
  58.    procedure attr_getc (skip : out Integer;
  59.                         fg, bg : in out Color_Number;
  60.                         result : out Boolean);
  61.  
  62.  
  63.    function subset (super, sub : Character_Attribute_Set) return Boolean is
  64.    begin
  65.       if
  66.         (super.Stand_Out or not sub.Stand_Out) and
  67.         (super.Under_Line or not sub.Under_Line) and
  68.         (super.Reverse_Video or not sub.Reverse_Video) and
  69.         (super.Blink or not sub.Blink) and
  70.         (super.Dim_Character or not sub.Dim_Character) and
  71.         (super.Bold_Character or not sub.Bold_Character) and
  72.         (super.Alternate_Character_Set or not sub.Alternate_Character_Set) and
  73.         (super.Invisible_Character or not sub.Invisible_Character) -- and
  74. --      (super.Protected_Character or not sub.Protected_Character) and
  75. --      (super.Horizontal or not sub.Horizontal) and
  76. --      (super.Left or not sub.Left) and
  77. --      (super.Low or not sub.Low) and
  78. --      (super.Right or not sub.Right) and
  79. --      (super.Top or not sub.Top) and
  80. --      (super.Vertical or not sub.Vertical)
  81.       then
  82.          return True;
  83.       else
  84.          return False;
  85.       end if;
  86.    end subset;
  87.  
  88.  
  89.    function intersect (b, a : Character_Attribute_Set) return Boolean is
  90.    begin
  91.       if
  92.         (a.Stand_Out and b.Stand_Out) or
  93.         (a.Under_Line and b.Under_Line) or
  94.         (a.Reverse_Video and b.Reverse_Video) or
  95.         (a.Blink and b.Blink) or
  96.         (a.Dim_Character and b.Dim_Character) or
  97.         (a.Bold_Character and b.Bold_Character) or
  98.         (a.Alternate_Character_Set and b.Alternate_Character_Set) or
  99.         (a.Invisible_Character and b.Invisible_Character) -- or
  100. --      (a.Protected_Character and b.Protected_Character) or
  101. --      (a.Horizontal and b.Horizontal) or
  102. --      (a.Left and b.Left) or
  103. --      (a.Low and b.Low) or
  104. --      (a.Right and b.Right) or
  105. --      (a.Top and b.Top) or
  106. --      (a.Vertical and b.Vertical)
  107.       then
  108.          return True;
  109.       else
  110.          return False;
  111.       end if;
  112.    end intersect;
  113.  
  114.    function has_A_COLOR (attr : Attributed_Character) return Boolean is
  115.    begin
  116.       if attr.Color /= Color_Pair (0) then
  117.          return True;
  118.       else
  119.          return False;
  120.       end if;
  121.    end has_A_COLOR;
  122.  
  123.    --  Print some text with attributes.
  124.    function show_attr (row  : Line_Position;
  125.                        skip : Natural;
  126.                        attr : Character_Attribute_Set;
  127.                        name : String;
  128.                        once : Boolean) return Line_Position is
  129.  
  130.       function make_record (n : Integer) return Character_Attribute_Set;
  131.       function make_record (n : Integer) return Character_Attribute_Set is
  132.          --  unsupported means true
  133.          a : Character_Attribute_Set := (others => False);
  134.          m : Integer;
  135.          rest : Integer;
  136.       begin
  137.          --  ncv is a bitmap with these fields
  138.          --              A_STANDOUT,
  139.          --              A_UNDERLINE,
  140.          --              A_REVERSE,
  141.          --              A_BLINK,
  142.          --              A_DIM,
  143.          --              A_BOLD,
  144.          --              A_INVIS,
  145.          --              A_PROTECT,
  146.          --              A_ALTCHARSET
  147.          --  It means no_color_video,
  148.          --  video attributes that can't be used with colors
  149.          --  see man terminfo.5
  150.          m := n mod 2;
  151.          rest := n / 2;
  152.          if 1 = m then
  153.             a.Stand_Out := True;
  154.          end if;
  155.          m := rest mod 2;
  156.          rest := rest / 2;
  157.          if 1 = m then
  158.             a.Under_Line := True;
  159.          end if;
  160.          m := rest mod 2;
  161.          rest := rest / 2;
  162.          if 1 = m then
  163.             a.Reverse_Video := True;
  164.          end if;
  165.          m := rest mod 2;
  166.          rest := rest / 2;
  167.          if 1 = m then
  168.             a.Blink := True;
  169.          end if;
  170.          m := rest mod 2;
  171.          rest := rest / 2;
  172.          if 1 = m then
  173.             a.Bold_Character := True;
  174.          end if;
  175.          m := rest mod 2;
  176.          rest := rest / 2;
  177.          if 1 = m then
  178.             a.Invisible_Character := True;
  179.          end if;
  180.          m := rest mod 2;
  181.          rest := rest / 2;
  182. --       if 1 = m then
  183. --          a.Protected_Character := True;
  184. --       end if;
  185.          m := rest mod 2;
  186.          rest := rest / 2;
  187.          if 1 = m then
  188.             a.Alternate_Character_Set := True;
  189.          end if;
  190.  
  191.          return a;
  192.       end make_record;
  193.  
  194.       ncv : constant Integer := Get_Number ("ncv");
  195.  
  196.    begin
  197.       Move_Cursor (Line => row, Column => 8);
  198.       Add (Str => name & " mode:");
  199.       Move_Cursor (Line => row, Column => 24);
  200.       Add (Ch => '|');
  201.       if skip /= 0 then
  202.          --  printw("%*s", skip, " ")
  203.          Add (Str => Ada.Strings.Fixed."*" (skip, ' '));
  204.       end if;
  205.       if once then
  206.          Switch_Character_Attribute (Attr => attr);
  207.       else
  208.          Set_Character_Attributes (Attr => attr);
  209.       end if;
  210.       Add (Str => "abcde fghij klmno pqrst uvwxy z");
  211.       if once then
  212.          Switch_Character_Attribute (Attr => attr, On => False);
  213.       end if;
  214.       if skip /= 0 then
  215.          Add (Str => Ada.Strings.Fixed."*" (skip, ' '));
  216.       end if;
  217.       Add (Ch => '|');
  218.       if attr /= Normal_Video then
  219.          declare begin
  220.             if not subset (super => Supported_Attributes, sub => attr) then
  221.                Add (Str => " (N/A)");
  222.             elsif ncv > 0 and has_A_COLOR (Get_Background) then
  223.                declare
  224.                   Color_Supported_Attributes :
  225.                     Character_Attribute_Set := make_record (ncv);
  226.                begin
  227.                   if intersect (Color_Supported_Attributes, attr) then
  228.                      Add (Str => " (NCV) ");
  229.                   end if;
  230.                end;
  231.             end if;
  232.          end;
  233.       end if;
  234.       return row + 2;
  235.    end show_attr;
  236.  
  237.    procedure attr_getc (skip : out Integer; fg, bg : in out Color_Number;
  238.                                             result : out Boolean) is
  239.       ch : Key_Code := Getchar;
  240.       nc : constant Color_Number := Color_Number (Number_Of_Colors);
  241.       curscr : Window;
  242.       pragma Import (C, curscr, "curscr");
  243.       --  curscr is not implemented in the Ada binding
  244.    begin
  245.       result := True;
  246.       if Ada.Characters.Handling.Is_Digit (Character'Val (ch)) then
  247.          skip := ctoi (Code_To_Char (ch));
  248.       elsif ch = CTRL ('L') then
  249.          Touch;
  250.          Touch (curscr);
  251.          Refresh;
  252.       elsif Has_Colors then
  253.          case ch is
  254.             --  Note the mathematical elegance compared to the C version.
  255.             when Character'Pos ('f') => fg := (fg + 1) mod nc;
  256.             when Character'Pos ('F') => fg := (fg - 1) mod nc;
  257.             when Character'Pos ('b') => bg := (bg + 1) mod nc;
  258.             when Character'Pos ('B') => bg := (bg - 1) mod nc;
  259.             when others =>
  260.                result := False;
  261.          end case;
  262.       else
  263.          result := False;
  264.       end if;
  265.    end attr_getc;
  266.  
  267.  
  268.  
  269.    --      pairs could be defined as array ( Color_Number(0) .. colors - 1) of
  270.    --      array (Color_Number(0).. colors - 1) of Boolean;
  271.    pairs : array (Color_Pair'Range) of Boolean := (others => False);
  272.    fg, bg : Color_Number := Black; -- = 0;
  273.    xmc : constant Integer := Get_Number ("xmc");
  274.    skip : Integer := xmc;
  275.    n : Integer;
  276.  
  277.    use Int_IO;
  278.  
  279. begin
  280.    pairs (0) := True;
  281.  
  282.    if skip < 0 then
  283.       skip := 0;
  284.    end if;
  285.    n := skip;
  286.  
  287.    loop
  288.       declare
  289.          row : Line_Position := 2;
  290.          normal : Attributed_Character := Blank2;
  291.          --  ???
  292.       begin
  293.          --  row := 2; -- weird, row is set to 0 without this.
  294.          --  TODO delete the above line, it was a gdb quirk that confused me
  295.          if Has_Colors then declare
  296.             pair : Color_Pair :=
  297.               Color_Pair (fg * Color_Number (Number_Of_Colors) + bg);
  298.          begin
  299.             --  Go though each color pair. Assume that the number of
  300.             --  Redefinable_Color_Pairs is 8*8 with predefined Colors 0..7
  301.             if not pairs (pair) then
  302.                Init_Pair (pair, fg, bg);
  303.                pairs (pair) := True;
  304.             end if;
  305.             normal.Color := pair;
  306.          end;
  307.          end if;
  308.          Set_Background (Ch => normal);
  309.          Erase;
  310.  
  311.          Add (Line => 0, Column => 20,
  312.               Str => "Character attribute test display");
  313.  
  314.          row := show_attr (row, n, (Stand_Out => True, others => False),
  315.                            "STANDOUT", True);
  316.          row := show_attr (row, n, (Reverse_Video => True, others => False),
  317.                            "REVERSE", True);
  318.          row := show_attr (row, n, (Bold_Character => True, others => False),
  319.                            "BOLD", True);
  320.          row := show_attr (row, n, (Under_Line => True, others => False),
  321.                            "UNDERLINE", True);
  322.          row := show_attr (row, n, (Dim_Character => True, others => False),
  323.                            "DIM", True);
  324.          row := show_attr (row, n, (Blink => True, others => False),
  325.                            "BLINK", True);
  326. --       row := show_attr (row, n, (Protected_Character => True,
  327. --                                  others => False), "PROTECT", True);
  328.          row := show_attr (row, n, (Invisible_Character => True,
  329.                                     others => False), "INVISIBLE", True);
  330.          row := show_attr (row, n, Normal_Video, "NORMAL", False);
  331.  
  332.          Move_Cursor (Line => row, Column => 8);
  333.          if xmc > -1 then
  334.             Add (Str => "This terminal does have the magic-cookie glitch");
  335.          else
  336.             Add (Str => "This terminal does not have the magic-cookie glitch");
  337.          end if;
  338.          Move_Cursor (Line => row + 1, Column => 8);
  339.          Add (Str => "Enter a digit to set gaps on each side of " &
  340.               "displayed attributes");
  341.          Move_Cursor (Line => row + 2, Column => 8);
  342.          Add (Str => "^L = repaint");
  343.          if Has_Colors then
  344.             declare tmp1 : String (1 .. 1);
  345.             begin
  346.                Add (Str => ".  f/F/b/F toggle colors (");
  347.                Put (tmp1, Integer (fg));
  348.                Add (Str => tmp1);
  349.                Add (Ch => '/');
  350.                Put (tmp1, Integer (bg));
  351.                Add (Str => tmp1);
  352.                Add (Ch => ')');
  353.             end;
  354.          end if;
  355.          Refresh;
  356.       end;
  357.  
  358.       declare result : Boolean; begin
  359.          attr_getc (n, fg, bg, result);
  360.          exit when not result;
  361.       end;
  362.    end loop;
  363.  
  364.    Set_Background (Ch => Blank2);
  365.    Erase;
  366.    End_Windows;
  367. end ncurses2.attr_test;
  368.